home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / atibgi.zip / VGADEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1990-05-16  |  41KB  |  1,484 lines
  1. program BGIDemo;
  2. {
  3.  
  4.   Turbo Pascal Borland Graphics Interface (BGI) demonstration
  5.   program. This program shows how to use many features of
  6.   the Graph unit.
  7.  
  8.   Copyright (c) 1985-89 by Borland International, Inc.
  9.  
  10.   Modified May 1, 1990 by Peter F. Jones to use my 256 Color BGI driver
  11.   for the ATI VGA Wonder.
  12.  
  13. }
  14.  
  15. uses
  16.   Crt, Dos, Graph;
  17.  
  18.  
  19. const
  20.   { The five fonts available }
  21.   Fonts : array[0..4] of string[13] =
  22.   ('DefaultFont', 'TriplexFont', 'SmallFont', 'SansSerifFont', 'GothicFont');
  23.  
  24.   { The five predefined line styles supported }
  25.   LineStyles : array[0..4] of string[9] =
  26.   ('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
  27.  
  28.   { The twelve predefined fill styles supported }
  29.   FillStyles : array[0..11] of string[14] =
  30.   ('EmptyFill', 'SolidFill', 'LineFill', 'LtSlashFill', 'SlashFill',
  31.    'BkSlashFill', 'LtBkSlashFill', 'HatchFill', 'XHatchFill',
  32.    'InterleaveFill', 'WideDotFill', 'CloseDotFill');
  33.  
  34.   { The two text directions available }
  35.   TextDirect : array[0..1] of string[8] = ('HorizDir', 'VertDir');
  36.  
  37.   { The Horizontal text justifications available }
  38.   HorizJust  : array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');
  39.  
  40.   { The vertical text justifications available }
  41.   VertJust   : array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');
  42.  
  43. var
  44.   GraphDriver : integer;  { The Graphics device driver }
  45.   GraphMode   : integer;  { The Graphics mode value }
  46.   MaxX, MaxY  : word;     { The maximum resolution of the screen }
  47.   ErrorCode   : integer;  { Reports any graphics errors }
  48.   MaxColor    : word;     { The maximum color value available }
  49.   OldExitProc : Pointer;  { Saves exit procedure address }
  50.  
  51. {$F+}
  52. procedure MyExitProc;
  53. begin
  54.   ExitProc := OldExitProc; { Restore exit procedure address }
  55.   CloseGraph;              { Shut down the graphics system }
  56. end; { MyExitProc }
  57. {$F-}
  58.  
  59. {$I ativw256.pas}
  60.  
  61. var
  62.   AutoDetectPointer : pointer;
  63.  
  64. procedure Initialize;
  65. { Initialize graphics and report any errors that may occur }
  66. var
  67.   InGraphicsMode : boolean; { Flags initialization of graphics mode }
  68.   PathToDriver   : string;  { Stores the DOS path to *.BGI & *.CHR }
  69. begin
  70.   { when using Crt and graphics, turn off Crt's memory-mapped writes }
  71.   DirectVideo := False;
  72.   OldExitProc := ExitProc;                { save previous exit proc }
  73.   ExitProc := @MyExitProc;                { insert our exit proc in chain }
  74.   PathToDriver := '';
  75.   repeat
  76.  
  77.     AutoDetectPointer := @detect_ATI_VGA_Wonder;   { Point to detection routine }
  78.     GraphDriver := InstallUserDriver('ativw256', AutoDetectPointer);
  79.     GraphDriver := Detect;
  80.  
  81.     InitGraph(GraphDriver, GraphMode, PathToDriver);
  82.     ErrorCode := GraphResult;             { preserve error return }
  83.     if ErrorCode <> grOK then             { error? }
  84.     begin
  85.       Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
  86.       if ErrorCode = grFileNotFound then  { Can't find driver file }
  87.       begin
  88.         Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
  89.         Readln(PathToDriver);
  90.         Writeln;
  91.       end
  92.       else
  93.         Halt(1);                          { Some other error: terminate }
  94.     end;
  95.   until ErrorCode = grOK;
  96.   Randomize;                { init random number generator }
  97.   MaxColor := GetMaxColor;  { Get the maximum allowable drawing color }
  98.   MaxX := GetMaxX;          { Get screen resolution values }
  99.   MaxY := GetMaxY;
  100. end; { Initialize }
  101.  
  102. function Int2Str(L : LongInt) : string;
  103. { Converts an integer to a string for use with OutText, OutTextXY }
  104. var
  105.   S : string;
  106. begin
  107.   Str(L, S);
  108.   Int2Str := S;
  109. end; { Int2Str }
  110.  
  111. function RandColor : word;
  112. { Returns a Random non-zero color value that is within the legal
  113.   color range for the selected device driver and graphics mode.
  114.   MaxColor is set to GetMaxColor by Initialize }
  115. begin
  116.   RandColor := Random(MaxColor)+1;
  117. end; { RandColor }
  118.  
  119. procedure DefaultColors;
  120. { Select the maximum color in the Palette for the drawing color }
  121. begin
  122.   SetColor(White);
  123. end; { DefaultColors }
  124.  
  125. procedure DrawBorder;
  126. { Draw a border around the current view port }
  127. var
  128.   ViewPort : ViewPortType;
  129. begin
  130.   DefaultColors;
  131.   SetLineStyle(SolidLn, 0, NormWidth);
  132.   GetViewSettings(ViewPort);
  133.   with ViewPort do
  134.     Rectangle(0, 0, x2-x1, y2-y1);
  135. end; { DrawBorder }
  136.  
  137. procedure FullPort;
  138. { Set the view port to the entire screen }
  139. begin
  140.   SetViewPort(0, 0, MaxX, MaxY, ClipOn);
  141. end; { FullPort }
  142.  
  143. procedure MainWindow(Header : string);
  144. { Make a default window and view port for demos }
  145. begin
  146.   DefaultColors;                           { Reset the colors }
  147.   ClearDevice;                             { Clear the screen }
  148.   SetTextStyle(DefaultFont, HorizDir, 1);  { Default text font }
  149.   SetTextJustify(CenterText, TopText);     { Left justify text }
  150.   FullPort;                                { Full screen view port }
  151.   OutTextXY(MaxX div 2, 2, Header);        { Draw the header }
  152.   { Draw main window }
  153.   SetViewPort(0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
  154.   DrawBorder;                              { Put a border around it }
  155.   { Move the edges in 1 pixel on all sides so border isn't in the view port }
  156.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  157. end; { MainWindow }
  158.  
  159. procedure StatusLine(Msg : string);
  160. { Display a status line at the bottom of the screen }
  161. begin
  162.   FullPort;
  163.   DefaultColors;
  164.   SetTextStyle(DefaultFont, HorizDir, 1);
  165.   SetTextJustify(CenterText, TopText);
  166.   SetLineStyle(SolidLn, 0, NormWidth);
  167.   SetFillStyle(EmptyFill, 0);
  168.   Bar(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);      { Erase old status line }
  169.   Rectangle(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);
  170.   OutTextXY(MaxX div 2, MaxY-(TextHeight('M')+2), Msg);
  171.   { Go back to the main window }
  172.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  173. end; { StatusLine }
  174.  
  175. procedure WaitToGo;
  176. { Wait for the user to abort the program or continue }
  177. const
  178.   Esc = #27;
  179. var
  180.   Ch : char;
  181. begin
  182.   StatusLine('Esc aborts or press a key...');
  183.   repeat until KeyPressed;
  184.   Ch := ReadKey;
  185.   if Ch = Esc then
  186.     Halt(0)                           { terminate program }
  187.   else
  188.     ClearDevice;                      { clear screen, go on with demo }
  189. end; { WaitToGo }
  190.  
  191. procedure GetDriverAndMode(var DriveStr, ModeStr : string);
  192. { Return strings describing the current device driver and graphics mode
  193.   for display of status report }
  194. begin
  195.   DriveStr := GetDriverName;
  196.   ModeStr := GetModeName(GetGraphMode);
  197. end; { GetDriverAndMode }
  198.  
  199. procedure ReportStatus;
  200. { Display the status of all query functions after InitGraph }
  201. const
  202.   X = 10;
  203. var
  204.   ViewInfo   : ViewPortType;     { Parameters for inquiry procedures }
  205.   LineInfo   : LineSettingsType;
  206.   FillInfo   : FillSettingsType;
  207.   TextInfo   : TextSettingsType;
  208.   Palette    : PaletteType;
  209.   DriverStr  : string;           { Driver and mode strings }
  210.   ModeStr    : string;
  211.   Y          : word;
  212.  
  213. procedure WriteOut(S : string);
  214. { Write out a string and increment to next line }
  215. begin
  216.   OutTextXY(X, Y, S);
  217.   Inc(Y, TextHeight('M')+2);
  218. end; { WriteOut }
  219.  
  220. begin { ReportStatus }
  221.   GetDriverAndMode(DriverStr, ModeStr);   { Get current settings }
  222.   GetViewSettings(ViewInfo);
  223.   GetLineSettings(LineInfo);
  224.   GetFillSettings(FillInfo);
  225.   GetTextSettings(TextInfo);
  226.   GetPalette(Palette);
  227.  
  228.   Y := 4;
  229.   MainWindow('Status report after InitGraph');
  230.   SetTextJustify(LeftText, TopText);
  231.   WriteOut('Graphics device    : '+DriverStr);
  232.   WriteOut('Graphics mode      : '+ModeStr);
  233.   WriteOut('Screen resolution  : (0, 0, '+Int2Str(GetMaxX)+', '+Int2Str(GetMaxY)+')');
  234.   with ViewInfo do
  235.   begin
  236.     WriteOut('Current view port  : ('+Int2Str(x1)+', '+Int2Str(y1)+', '+Int2Str(x2)+', '+Int2Str(y2)+')');
  237.     if ClipOn then
  238.       WriteOut('Clipping           : ON')
  239.     else
  240.       WriteOut('Clipping           : OFF');
  241.   end;
  242.   WriteOut('Current position   : ('+Int2Str(GetX)+', '+Int2Str(GetY)+')');
  243.   WriteOut('Palette entries    : '+Int2Str(Palette.Size));
  244.   WriteOut('GetMaxColor        : '+Int2Str(GetMaxColor));
  245.   WriteOut('Current color      : '+Int2Str(GetColor));
  246.   with LineInfo do
  247.   begin
  248.     WriteOut('Line style         : '+LineStyles[LineStyle]);
  249.     WriteOut('Line thickness     : '+Int2Str(Thickness));
  250.   end;
  251.   with FillInfo do
  252.   begin
  253.     WriteOut('Current fill style : '+FillStyles[Pattern]);
  254.     WriteOut('Current fill color : '+Int2Str(Color));
  255.   end;
  256.   with TextInfo do
  257.   begin
  258.     WriteOut('Current font       : '+Fonts[Font]);
  259.     WriteOut('Text direction     : '+TextDirect[Direction]);
  260.     WriteOut('Character size     : '+Int2Str(CharSize));
  261.     WriteOut('Horizontal justify : '+HorizJust[Horiz]);
  262.     WriteOut('Vertical justify   : '+VertJust[Vert]);
  263.   end;
  264.   WaitToGo;
  265. end; { ReportStatus }
  266.  
  267. procedure FillEllipsePlay;
  268. { Random filled ellipse demonstration }
  269. const
  270.   MaxFillStyles = 12; { patterns 0..11 }
  271. var
  272.   MaxRadius : word;
  273.   FillColor : integer;
  274. begin
  275.   MainWindow('FillEllipse demonstration');
  276.   StatusLine('Esc aborts or press a key');
  277.   MaxRadius := MaxY div 10;
  278.   SetLineStyle(SolidLn, 0, NormWidth);
  279.   repeat
  280.     FillColor := RandColor;
  281.     SetColor(FillColor);
  282.     SetFillStyle(Random(MaxFillStyles), FillColor);
  283.     FillEllipse(Random(MaxX), Random(MaxY),
  284.                 Random(MaxRadius), Random(MaxRadius));
  285.   until KeyPressed;
  286.   WaitToGo;
  287. end; { FillEllipsePlay }
  288.  
  289. procedure SectorPlay;
  290. { Draw random sectors on the screen }
  291. const
  292.   MaxFillStyles = 12; { patterns 0..11 }
  293. var
  294.   MaxRadius : word;
  295.   FillColor : integer;
  296.   EndAngle  : integer;
  297. begin
  298.   MainWindow('Sector demonstration');
  299.   StatusLine('Esc aborts or press a key');
  300.   MaxRadius := MaxY div 10;
  301.   SetLineStyle(SolidLn, 0, NormWidth);
  302.   repeat
  303.     FillColor := RandColor;
  304.     SetColor(FillColor);
  305.     SetFillStyle(Random(MaxFillStyles), FillColor);
  306.     EndAngle := Random(360);
  307.     Sector(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle,
  308.            Random(MaxRadius), Random(MaxRadius));
  309.   until KeyPressed;
  310.   WaitToGo;
  311. end; { SectorPlay }
  312.  
  313. procedure WriteModePlay;
  314. { Demonstrate the SetWriteMode procedure for XOR lines }
  315. const
  316.   DelayValue = 50;  { milliseconds to delay }
  317. var
  318.   ViewInfo      : ViewPortType;
  319.   Color         : word;
  320.   Left, Top     : integer;
  321.   Right, Bottom : integer;
  322.   Step          : integer; { step for rectangle shrinking }
  323. begin
  324.   MainWindow('SetWriteMode demonstration');
  325.   StatusLine('Esc aborts or press a key');
  326.   GetViewSettings(ViewInfo);
  327.   Left := 0;
  328.   Top := 0;
  329.   with ViewInfo do
  330.   begin
  331.     Right := x2-x1;
  332.     Bottom := y2-y1;
  333.   end;
  334.   Step := Bottom div 50;
  335.   SetColor(White);
  336.   Line(Left, Top, Right, Bottom);
  337.   Line(Left, Bottom, Right, Top);
  338.   SetWriteMode(XORPut);                    { Set XOR write mode }
  339.   repeat
  340.     Line(Left, Top, Right, Bottom);        { Draw XOR lines }
  341.     Line(Left, Bottom, Right, Top);
  342.     Rectangle(Left, Top, Right, Bottom);   { Draw XOR rectangle }
  343.     Delay(DelayValue);                     { Wait }
  344.     Line(Left, Top, Right, Bottom);        { Erase lines }
  345.     Line(Left, Bottom, Right, Top);
  346.     Rectangle(Left, Top, Right, Bottom);   { Erase rectangle }
  347.     if (Left+Step < Right) and (Top+Step < Bottom) then
  348.       begin
  349.         Inc(Left, Step);                  { Shrink rectangle }
  350.         Inc(Top, Step);
  351.         Dec(Right, Step);
  352.         Dec(Bottom, Step);
  353.       end
  354.     else
  355.       begin
  356.         Color := RandColor;                { New color }
  357.         SetColor(Color);
  358.         Left := 0;                         { Original large rectangle }
  359.         Top := 0;
  360.         with ViewInfo do
  361.         begin
  362.           Right := x2-x1;
  363.           Bottom := y2-y1;
  364.         end;
  365.       end;
  366.   until KeyPressed;
  367.   SetWriteMode(CopyPut);                   { back to overwrite mode }
  368.   WaitToGo;
  369. end; { WriteModePlay }
  370.  
  371. procedure AspectRatioPlay;
  372. { Demonstrate  SetAspectRatio command }
  373. var
  374.   ViewInfo   : ViewPortType;
  375.   CenterX    : integer;
  376.   CenterY    : integer;
  377.   Radius     : word;
  378.   Xasp, Yasp : word;
  379.   i          : integer;
  380.   RadiusStep : word;
  381. begin
  382.   MainWindow('SetAspectRatio demonstration');
  383.   GetViewSettings(ViewInfo);
  384.   with ViewInfo do
  385.   begin
  386.     CenterX := (x2-x1) div 2;
  387.     CenterY := (y2-y1) div 2;
  388.     Radius := 3*((y2-y1) div 5);
  389.   end;
  390.   RadiusStep := (Radius div 30);
  391.   Circle(CenterX, CenterY, Radius);
  392.   GetAspectRatio(Xasp, Yasp);
  393.   for i := 1 to 30 do
  394.   begin
  395.     SetAspectRatio(Xasp, Yasp+(I*GetMaxX));    { Increase Y aspect factor }
  396.     Circle(CenterX, CenterY, Radius);
  397.     Dec(Radius, RadiusStep);                   { Shrink radius }
  398.   end;
  399.   Inc(Radius, RadiusStep*30);
  400.   for i := 1 to 30 do
  401.   begin
  402.     SetAspectRatio(Xasp+(I*GetMaxX), Yasp);    { Increase X aspect factor }
  403.     if Radius > RadiusStep then
  404.       Dec(Radius, RadiusStep);                 { Shrink radius }
  405.     Circle(CenterX, CenterY, Radius);
  406.   end;
  407.   SetAspectRatio(Xasp, Yasp);                  { back to original aspect }
  408.   WaitToGo;
  409. end; { AspectRatioPlay }
  410.  
  411. procedure TextPlay;
  412. { Demonstrate text justifications and text sizing }
  413. var
  414.   Size : word;
  415.   W, H, X, Y : word;
  416.   ViewInfo : ViewPortType;
  417. begin
  418.   MainWindow('SetTextJustify / SetUserCharSize demo');
  419.   GetViewSettings(ViewInfo);
  420.   with ViewInfo do
  421.   begin
  422.     SetTextStyle(TriplexFont, VertDir, 4);
  423.     Y := (y2-y1) - 2;
  424.     SetTextJustify(CenterText, BottomText);
  425.     OutTextXY(2*TextWidth('M'), Y, 'Vertical');
  426.     SetTextStyle(TriplexFont, HorizDir, 4);
  427.     SetTextJustify(LeftText, TopText);
  428.     OutTextXY(2*TextWidth('M'), 2, 'Horizontal');
  429.     SetTextJustify(CenterText, CenterText);
  430.     X := (x2-x1) div 2;
  431.     Y := TextHeight('H');
  432.     for Size := 1 to 4 do
  433.     begin
  434.       SetTextStyle(TriplexFont, HorizDir, Size);
  435.       H := TextHeight('M');
  436.       W := TextWidth('M');
  437.       Inc(Y, H);
  438.       OutTextXY(X, Y, 'Size '+Int2Str(Size));
  439.     end;
  440.     Inc(Y, H div 2);
  441.     SetTextJustify(CenterText, TopText);
  442.     SetUserCharSize(5, 6, 3, 2);
  443.     SetTextStyle(TriplexFont, HorizDir, UserCharSize);
  444.     OutTextXY((x2-x1) div 2, Y, 'User defined size!');
  445.   end;
  446.   WaitToGo;
  447. end; { TextPlay }
  448.  
  449. procedure TextDump;
  450. { Dump the complete character sets to the screen }
  451. const
  452.   CGASizes  : array[0..4] of word = (1, 3, 7, 3, 3);
  453.   NormSizes : array[0..4] of word = (1, 4, 7, 4, 4);
  454. var
  455.   Font : word;
  456.   ViewInfo : ViewPortType;
  457.   Ch : char;
  458. begin
  459.   for Font := 0 to 4 do
  460.   begin
  461.     MainWindow(Fonts[Font]+' character set');
  462.     GetViewSettings(ViewInfo);
  463.     with ViewInfo do
  464.     begin
  465.       SetTextJustify(LeftText, TopText);
  466.       MoveTo(2, 3);
  467.       if Font = DefaultFont then
  468.         begin
  469.           SetTextStyle(Font, HorizDir, 1);
  470.           Ch := #0;
  471.           repeat
  472.             OutText(Ch);
  473.             if (GetX + TextWidth('M')) > (x2-x1) then
  474.               MoveTo(2, GetY + TextHeight('M')+3);
  475.             Ch := Succ(Ch);
  476.           until (Ch >= #255);
  477.         end
  478.       else
  479.         begin
  480.           if MaxY < 200 then
  481.             SetTextStyle(Font, HorizDir, CGASizes[Font])
  482.           else
  483.             SetTextStyle(Font, HorizDir, NormSizes[Font]);
  484.           Ch := '!';
  485.           repeat
  486.             OutText(Ch);
  487.             if (GetX + TextWidth('M')) > (x2-x1) then
  488.               MoveTo(2, GetY + TextHeight('M')+3);
  489.             Ch := Succ(Ch);
  490.           until (Ord(Ch) = Ord('~')+1);
  491.         end;
  492.     end; { with }
  493.     WaitToGo;
  494.   end; { for loop }
  495. end; { TextDump }
  496.  
  497. procedure LineToPlay;
  498. { Demonstrate MoveTo and LineTo commands }
  499. const
  500.   MaxPoints = 15;
  501. var
  502.   Points     : array[0..MaxPoints] of PointType;
  503.   ViewInfo   : ViewPortType;
  504.   I, J       : integer;
  505.   CenterX    : integer;   { The center point of the circle }
  506.   CenterY    : integer;
  507.   Radius     : word;
  508.   StepAngle  : word;
  509.   Xasp, Yasp : word;
  510.   Radians    : real;
  511.  
  512. function AdjAsp(Value : integer) : integer;
  513. { Adjust a value for the aspect ratio of the device }
  514. begin
  515.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  516. end; { AdjAsp }
  517.  
  518. begin
  519.   MainWindow('MoveTo, LineTo demonstration');
  520.   GetAspectRatio(Xasp, Yasp);
  521.   GetViewSettings(ViewInfo);
  522.   with ViewInfo do
  523.   begin
  524.     CenterX := (x2-x1) div 2;
  525.     CenterY := (y2-y1) div 2;
  526.     Radius := CenterY;
  527.     while (CenterY+AdjAsp(Radius)) < (y2-y1)-20 do
  528.       Inc(Radius);
  529.   end;
  530.   StepAngle := 360 div MaxPoints;
  531.   for I := 0 to MaxPoints - 1 do
  532.   begin
  533.     Radians := (StepAngle * I) * Pi / 180;
  534.     Points[I].X := CenterX + round(Cos(Radians) * Radius);
  535.     Points[I].Y := CenterY - AdjAsp(round(Sin(Radians) * Radius));
  536.   end;
  537.   Circle(CenterX, CenterY, Radius);
  538.   for I := 0 to MaxPoints - 1 do
  539.   begin
  540.     for J := I to MaxPoints - 1 do
  541.     begin
  542.       MoveTo(Points[I].X, Points[I].Y);
  543.       LineTo(Points[J].X, Points[J].Y);
  544.     end;
  545.   end;
  546.   WaitToGo;
  547. end; { LineToPlay }
  548.  
  549. procedure LineRelPlay;
  550. { Demonstrate MoveRel and LineRel commands }
  551. const
  552.   MaxPoints = 12;
  553. var
  554.   Poly     : array[1..MaxPoints] of PointType; { Stores a polygon for filling }
  555.   CurrPort : ViewPortType;
  556.  
  557. procedure DrawTesseract;
  558. { Draw a Tesseract on the screen with relative move and
  559.   line drawing commands, also create a polygon for filling }
  560. const
  561.   CheckerBoard : FillPatternType = (0, $10, $28, $44, $28, $10, 0, 0);
  562. var
  563.   X, Y, W, H   : integer;
  564.  
  565. begin
  566.   GetViewSettings(CurrPort);
  567.   with CurrPort do
  568.   begin
  569.     W := (x2-x1) div 9;
  570.     H := (y2-y1) div 8;
  571.     X := ((x2-x1) div 2) - round(2.5 * W);
  572.     Y := ((y2-y1) div 2) - (3 * H);
  573.  
  574.     { Border around viewport is outer part of polygon }
  575.     Poly[1].X := 0;     Poly[1].Y := 0;
  576.     Poly[2].X := x2-x1; Poly[2].Y := 0;
  577.     Poly[3].X := x2-x1; Poly[3].Y := y2-y1;
  578.     Poly[4].X := 0;     Poly[4].Y := y2-y1;
  579.     Poly[5].X := 0;     Poly[5].Y := 0;
  580.     MoveTo(X, Y);
  581.  
  582.     { Grab the whole in the polygon as we draw }
  583.     MoveRel(0, H);      Poly[6].X := GetX;  Poly[6].Y := GetY;
  584.     MoveRel(W, -H);     Poly[7].X := GetX;  Poly[7].Y := GetY;
  585.     MoveRel(4*W, 0);    Poly[8].X := GetX;  Poly[8].Y := GetY;
  586.     MoveRel(0, 5*H);    Poly[9].X := GetX;  Poly[9].Y := GetY;
  587.     MoveRel(-W, H);     Poly[10].X := GetX; Poly[10].Y := GetY;
  588.     MoveRel(-4*W, 0);   Poly[11].X := GetX; Poly[11].Y := GetY;
  589.     MoveRel(0, -5*H);   Poly[12].X := GetX; Poly[12].Y := GetY;
  590.  
  591.     { Fill the polygon with a user defined fill pattern }
  592.     SetFillPattern(CheckerBoard, White);
  593.     FillPoly(12, Poly);
  594.  
  595.     MoveRel(W, -H);
  596.     LineRel(0, 5*H);   LineRel(2*W, 0);    LineRel(0, -3*H);
  597.     LineRel(W, -H);    LineRel(0, 5*H);    MoveRel(0, -5*H);
  598.     LineRel(-2*W, 0);  LineRel(0, 3*H);    LineRel(-W, H);
  599.     MoveRel(W, -H);    LineRel(W, 0);      MoveRel(0, -2*H);
  600.     LineRel(-W, 0);
  601.  
  602.     { Flood fill the center }
  603. (*    FloodFill((x2-x1) div 2, (y2-y1) div 2, MaxColor); *)
  604.   end;
  605. end; { DrawTesseract }
  606.  
  607. begin
  608.   MainWindow('LineRel / MoveRel demonstration');
  609.   GetViewSettings(CurrPort);
  610.   with CurrPort do
  611.     { Move the viewport out 1 pixel from each end }
  612.     SetViewPort(x1-1, y1-1, x2+1, y2+1, ClipOn);
  613.   DrawTesseract;
  614.   WaitToGo;
  615. end; { LineRelPlay }
  616.  
  617. procedure PiePlay;
  618. { Demonstrate  PieSlice and GetAspectRatio commands }
  619. var
  620.   ViewInfo   : ViewPortType;
  621.   CenterX    : integer;
  622.   CenterY    : integer;
  623.   Radius     : word;
  624.   Xasp, Yasp : word;
  625.   X, Y       : integer;
  626.  
  627. function AdjAsp(Value : integer) : integer;
  628. { Adjust a value for the aspect ratio of the device }
  629. begin
  630.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  631. end; { AdjAsp }
  632.  
  633. procedure GetTextCoords(AngleInDegrees, Radius : word; var X, Y : integer);
  634. { Get the coordinates of text for pie slice labels }
  635. var
  636.   Radians : real;
  637. begin
  638.   Radians := AngleInDegrees * Pi / 180;
  639.   X := round(Cos(Radians) * Radius);
  640.   Y := round(Sin(Radians) * Radius);
  641. end; { GetTextCoords }
  642.  
  643. begin
  644.   MainWindow('PieSlice / GetAspectRatio demonstration');
  645.   GetAspectRatio(Xasp, Yasp);
  646.   GetViewSettings(ViewInfo);
  647.   with ViewInfo do
  648.   begin
  649.     CenterX := (x2-x1) div 2;
  650.     CenterY := ((y2-y1) div 2) + 20;
  651.     Radius := (y2-y1) div 3;
  652.     while AdjAsp(Radius) < round((y2-y1) / 3.6) do
  653.       Inc(Radius);
  654.   end;
  655.   SetTextStyle(TriplexFont, HorizDir, 4);
  656.   SetTextJustify(CenterText, TopText);
  657.   OutTextXY(CenterX, 0, 'This is a pie chart!');
  658.  
  659.   SetTextStyle(TriplexFont, HorizDir, 3);
  660.  
  661.   SetFillStyle(SolidFill, RandColor);
  662.   PieSlice(CenterX+10, CenterY-AdjAsp(10), 0, 90, Radius);
  663.   GetTextCoords(45, Radius, X, Y);
  664.   SetTextJustify(LeftText, BottomText);
  665.   OutTextXY(CenterX+10+X+TextWidth('H'), CenterY-AdjAsp(10+Y), '25 %');
  666.  
  667.   SetFillStyle(HatchFill, RandColor);
  668.   PieSlice(CenterX, CenterY, 225, 360, Radius);
  669.   GetTextCoords(293, Radius, X, Y);
  670.   SetTextJustify(LeftText, TopText);
  671.   OutTextXY(CenterX+X+TextWidth('H'), CenterY-AdjAsp(Y), '37.5 %');
  672.  
  673.   SetFillStyle(InterleaveFill, RandColor);
  674.   PieSlice(CenterX-10, CenterY, 135, 225, Radius);
  675.   GetTextCoords(180, Radius, X, Y);
  676.   SetTextJustify(RightText, CenterText);
  677.   OutTextXY(CenterX-10+X-TextWidth('H'), CenterY-AdjAsp(Y), '25 %');
  678.  
  679.   SetFillStyle(WideDotFill, RandColor);
  680.   PieSlice(CenterX, CenterY, 90, 135, Radius);
  681.   GetTextCoords(112, Radius, X, Y);
  682.   SetTextJustify(RightText, BottomText);
  683.   OutTextXY(CenterX+X-TextWidth('H'), CenterY-AdjAsp(Y), '12.5 %');
  684.  
  685.   WaitToGo;
  686. end; { PiePlay }
  687.  
  688. procedure Bar3DPlay;
  689. { Demonstrate Bar3D command }
  690. const
  691.   NumBars   = 7;  { The number of bars drawn }
  692.   BarHeight : array[1..NumBars] of byte = (1, 3, 2, 5, 4, 2, 1);
  693.   YTicks    = 5;  { The number of tick marks on the Y axis }
  694. var
  695.   ViewInfo : ViewPortType;
  696.   H        : word;
  697.   XStep    : real;
  698.   YStep    : real;
  699.   I, J     : integer;
  700.   Depth    : word;
  701.   Color    : word;
  702. begin
  703.   MainWindow('Bar3D / Rectangle demonstration');
  704.   H := 3*TextHeight('M');
  705.   GetViewSettings(ViewInfo);
  706.   SetTextJustify(CenterText, TopText);
  707.   SetTextStyle(TriplexFont, HorizDir, 4);
  708.   OutTextXY(MaxX div 2, 6, 'These are 3D bars !');
  709.   SetTextStyle(DefaultFont, HorizDir, 1);
  710.   with ViewInfo do
  711.     SetViewPort(x1+50, y1+40, x2-50, y2-10, ClipOn);
  712.   GetViewSettings(ViewInfo);
  713.   with ViewInfo do
  714.   begin
  715.     Line(H, H, H, (y2-y1)-H);
  716.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  717.     YStep := ((y2-y1)-(2*H)) / YTicks;
  718.     XStep := ((x2-x1)-(2*H)) / NumBars;
  719.     J := (y2-y1)-H;
  720.     SetTextJustify(CenterText, CenterText);
  721.  
  722.     { Draw the Y axis and ticks marks }
  723.     for I := 0 to Yticks do
  724.     begin
  725.       Line(H div 2, J, H, J);
  726.       OutTextXY(0, J, Int2Str(I));
  727.       J := Round(J-Ystep);
  728.     end;
  729.  
  730.  
  731.     Depth := trunc(0.25 * XStep);    { Calculate depth of bar }
  732.  
  733.     { Draw X axis, bars, and tick marks }
  734.     SetTextJustify(CenterText, TopText);
  735.     J := H;
  736.     for I := 1 to Succ(NumBars) do
  737.     begin
  738.       SetColor(White);
  739.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  740.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I-1));
  741.       if I <> Succ(NumBars) then
  742.       begin
  743.         Color := RandColor;
  744.         SetFillStyle(I, Color);
  745.         SetColor(Color);
  746.         Bar3D(J, round((y2-y1-H)-(BarHeight[I] * Ystep)),
  747.                  round(J+Xstep-Depth), round((y2-y1)-H-1), Depth, TopOn);
  748.         J := Round(J+Xstep);
  749.       end;
  750.     end;
  751.  
  752.   end;
  753.   WaitToGo;
  754. end; { Bar3DPlay }
  755.  
  756. procedure SolidBarPlay;
  757. { Draw random solid bars on the screen }
  758. var
  759.   MaxWidth  : integer;
  760.   MaxHeight : integer;
  761.   ViewInfo  : ViewPortType;
  762.   Color     : word;
  763. begin
  764.   MainWindow('Random Solid Bars');
  765.   StatusLine('Esc aborts or press a key');
  766.   GetViewSettings(ViewInfo);
  767.   with ViewInfo do
  768.   begin
  769.     MaxWidth := x2-x1;
  770.     MaxHeight := y2-y1;
  771.   end;
  772.   repeat
  773.     Color := Random(256);  { RandColor }
  774.     SetColor(Color);
  775.     SetFillStyle(SolidFill, Color);
  776.     Bar3D(Random(MaxWidth), Random(MaxHeight),
  777.           Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  778.   until KeyPressed;
  779.   WaitToGo;
  780. end; { SolidBarPlay }
  781.  
  782. procedure BarPlay;
  783. { Demonstrate Bar command }
  784. const
  785.   NumBars   = 5;
  786.   BarHeight : array[1..NumBars] of byte = (1, 3, 5, 2, 4);
  787.   Styles    : array[1..NumBars] of byte = (1, 3, 10, 5, 9);
  788. var
  789.   ViewInfo  : ViewPortType;
  790.   BarNum    : word;
  791.   H         : word;
  792.   XStep     : real;
  793.   YStep     : real;
  794.   I, J      : integer;
  795.   Color     : word;
  796. begin
  797.   MainWindow('Bar / Rectangle demonstration');
  798.   H := 3*TextHeight('M');
  799.   GetViewSettings(ViewInfo);
  800.   SetTextJustify(CenterText, TopText);
  801.   SetTextStyle(TriplexFont, HorizDir, 4);
  802.   OutTextXY(MaxX div 2, 6, 'These are 2D bars !');
  803.   SetTextStyle(DefaultFont, HorizDir, 1);
  804.   with ViewInfo do
  805.     SetViewPort(x1+50, y1+30, x2-50, y2-10, ClipOn);
  806.   GetViewSettings(ViewInfo);
  807.   with ViewInfo do
  808.   begin
  809.     Line(H, H, H, (y2-y1)-H);
  810.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  811.     YStep := ((y2-y1)-(2*H)) / NumBars;
  812.     XStep := ((x2-x1)-(2*H)) / NumBars;
  813.     J := (y2-y1)-H;
  814.     SetTextJustify(CenterText, CenterText);
  815.  
  816.     { Draw Y axis with tick marks }
  817.     for I := 0 to NumBars do
  818.     begin
  819.       Line(H div 2, J, H, J);
  820.       OutTextXY(0, J, Int2Str(i));
  821.       J := Round(J-Ystep);
  822.     end;
  823.  
  824.     { Draw X axis, bars, and tick marks }
  825.     J := H;
  826.     SetTextJustify(CenterText, TopText);
  827.     for I := 1 to Succ(NumBars) do
  828.     begin
  829.       SetColor(White);
  830.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  831.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I));
  832.       if I <> Succ(NumBars) then
  833.       begin
  834.         Color := RandColor;
  835.         SetFillStyle(Styles[I], Color);
  836.         SetColor(Color);
  837.         Bar(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  838.         Rectangle(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  839.       end;
  840.       J := Round(J+Xstep);
  841.     end;
  842.  
  843.   end;
  844.   WaitToGo;
  845. end; { BarPlay }
  846.  
  847. procedure CirclePlay;
  848. { Draw random circles on the screen }
  849. var
  850.   MaxRadius : word;
  851. begin
  852.   MainWindow('Circle demonstration');
  853.   StatusLine('Esc aborts or press a key');
  854.   MaxRadius := MaxY div 10;
  855.   SetLineStyle(SolidLn, 0, NormWidth);
  856.   repeat
  857.     SetColor(RandColor);
  858.     Circle(Random(MaxX), Random(MaxY), Random(MaxRadius));
  859.   until KeyPressed;
  860.   WaitToGo;
  861. end; { CirclePlay }
  862.  
  863.  
  864. procedure RandBarPlay;
  865. { Draw random bars on the screen }
  866. var
  867.   MaxWidth  : integer;
  868.   MaxHeight : integer;
  869.   ViewInfo  : ViewPortType;
  870.   Color     : word;
  871. begin
  872.   MainWindow('Random Bars');
  873.   StatusLine('Esc aborts or press a key');
  874.   GetViewSettings(ViewInfo);
  875.   with ViewInfo do
  876.   begin
  877.     MaxWidth := x2-x1;
  878.     MaxHeight := y2-y1;
  879.   end;
  880.   repeat
  881.     Color := RandColor;
  882.     SetColor(Color);
  883.     SetFillStyle(Random(CloseDotFill)+1, Color);
  884.     Bar3D(Random(MaxWidth), Random(MaxHeight),
  885.           Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  886.   until KeyPressed;
  887.   WaitToGo;
  888. end; { RandBarPlay }
  889.  
  890. procedure ArcPlay;
  891. { Draw random arcs on the screen }
  892. var
  893.   MaxRadius : word;
  894.   EndAngle : word;
  895.   ArcInfo : ArcCoordsType;
  896. begin
  897.   MainWindow('Arc / GetArcCoords demonstration');
  898.   StatusLine('Esc aborts or press a key');
  899.   MaxRadius := MaxY div 10;
  900.   repeat
  901.     SetColor(RandColor);
  902.     EndAngle := Random(360);
  903.     SetLineStyle(SolidLn, 0, NormWidth);
  904.     Arc(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle, Random(MaxRadius));
  905.     GetArcCoords(ArcInfo);
  906.     with ArcInfo do
  907.     begin
  908.       Line(X, Y, XStart, YStart);
  909.       Line(X, Y, Xend, Yend);
  910.     end;
  911.   until KeyPressed;
  912.   WaitToGo;
  913. end; { ArcPlay }
  914.  
  915. procedure PutPixelPlay;
  916. { Demonstrate the PutPixel and GetPixel commands }
  917. const
  918.   Seed   = 1962; { A seed for the random number generator }
  919.   NumPts = 2000; { The number of pixels plotted }
  920.   Esc    = #27;
  921. var
  922.   I : word;
  923.   X, Y, Color : word;
  924.   XMax, YMax  : integer;
  925.   ViewInfo    : ViewPortType;
  926. begin
  927.   MainWindow('PutPixel / GetPixel demonstration');
  928.   StatusLine('Esc aborts or press a key...');
  929.  
  930.   GetViewSettings(ViewInfo);
  931.   with ViewInfo do
  932.   begin
  933.     XMax := (x2-x1-1);
  934.     YMax := (y2-y1-1);
  935.   end;
  936.  
  937.   while not KeyPressed do
  938.   begin
  939.     { Plot random pixels }
  940.     RandSeed := Seed;
  941.     I := 0;
  942.     while (not KeyPressed) and (I < NumPts) do
  943.     begin
  944.       Inc(I);
  945.       PutPixel(Random(XMax)+1, Random(YMax)+1, RandColor);
  946.     end;
  947.  
  948.     { Erase pixels }
  949.     RandSeed := Seed;
  950.     I := 0;
  951.     while (not KeyPressed) and (I < NumPts) do
  952.     begin
  953.       Inc(I);
  954.       X := Random(XMax)+1;
  955.       Y := Random(YMax)+1;
  956.       Color := GetPixel(X, Y);
  957.       if Color = RandColor then
  958.         PutPixel(X, Y, 0);
  959.     end;
  960.   end;
  961.   WaitToGo;
  962. end; { PutPixelPlay }
  963.  
  964. procedure PutImagePlay;
  965. { Demonstrate the GetImage and PutImage commands }
  966.  
  967. const
  968.   r  = 20;
  969.   StartX = 100;
  970.   StartY = 50;
  971.  
  972. var
  973.   CurPort : ViewPortType;
  974.  
  975. procedure MoveSaucer(var X, Y : integer; Width, Height : integer);
  976. var
  977.   Step : integer;
  978. begin
  979.   Step := Random(2*r);
  980.   if Odd(Step) then
  981.     Step := -Step;
  982.   X := X + Step;
  983.   Step := Random(r);
  984.   if Odd(Step) then
  985.     Step := -Step;
  986.   Y := Y + Step;
  987.  
  988.   { Make saucer bounce off viewport walls }
  989.   with CurPort do
  990.   begin
  991.     if (x1 + X + Width - 1 > x2) then
  992.       X := x2-x1 - Width + 1
  993.     else
  994.       if (X < 0) then
  995.         X := 0;
  996.     if (y1 + Y + Height - 1 > y2) then
  997.       Y := y2-y1 - Height + 1
  998.     else
  999.       if (Y < 0) then
  1000.         Y := 0;
  1001.   end;
  1002. end; { MoveSaucer }
  1003.  
  1004. var
  1005.   Pausetime : word;
  1006.   Saucer    : pointer;
  1007.   X, Y      : integer;
  1008.   ulx, uly  : word;
  1009.   lrx, lry  : word;
  1010.   Size      : word;
  1011.   I         : word;
  1012. begin
  1013.   ClearDevice;
  1014.   FullPort;
  1015.  
  1016.   { PaintScreen }
  1017.   ClearDevice;
  1018.   MainWindow('GetImage / PutImage Demonstration');
  1019.   StatusLine('Esc aborts or press a key...');
  1020.   GetViewSettings(CurPort);
  1021.  
  1022.   { DrawSaucer }
  1023.   Ellipse(StartX, StartY, 0, 360, r, (r div 3)+2);
  1024.   Ellipse(StartX, StartY-4, 190, 357, r, r div 3);
  1025.   Line(StartX+7, StartY-6, StartX+10, StartY-12);
  1026.   Circle(StartX+10, StartY-12, 2);
  1027.   Line(StartX-7, StartY-6, StartX-10, StartY-12);
  1028.   Circle(StartX-10, StartY-12, 2);
  1029.   SetFillStyle(SolidFill, White);
  1030.   FloodFill(StartX+1, StartY+4, GetColor);
  1031.  
  1032.   { ReadSaucerImage }
  1033.   ulx := StartX-(r+1);
  1034.   uly := StartY-14;
  1035.   lrx := StartX+(r+1);
  1036.   lry := StartY+(r div 3)+3;
  1037.  
  1038.   Size := ImageSize(ulx, uly, lrx, lry);
  1039.   GetMem(Saucer, Size);
  1040.   GetImage(ulx, uly, lrx, lry, Saucer^);
  1041.   PutImage(ulx, uly, Saucer^, XORput);               { erase image }
  1042.  
  1043.   { Plot some "stars" }
  1044.   for I := 1 to 1000 do
  1045.     PutPixel(Random(MaxX), Random(MaxY), RandColor);
  1046.   X := MaxX div 2;
  1047.   Y := MaxY div 2;
  1048.   PauseTime := 70;
  1049.  
  1050.   { Move the saucer around }
  1051.   repeat
  1052.     PutImage(X, Y, Saucer^, XORput);                 { draw image }
  1053.     Delay(PauseTime);
  1054.     PutImage(X, Y, Saucer^, XORput);                 { erase image }
  1055.     MoveSaucer(X, Y, lrx - ulx + 1, lry - uly + 1);  { width/height }
  1056.   until KeyPressed;
  1057.   FreeMem(Saucer, size);
  1058.   WaitToGo;
  1059. end; { PutImagePlay }
  1060.  
  1061. procedure PolyPlay;
  1062. { Draw random polygons with random fill styles on the screen }
  1063. const
  1064.   MaxPts = 5;
  1065. type
  1066.   PolygonType = array[1..MaxPts] of PointType;
  1067. var
  1068.   Poly : PolygonType;
  1069.   I, Color : word;
  1070. begin
  1071.   MainWindow('FillPoly demonstration');
  1072.   StatusLine('Esc aborts or press a key...');
  1073.   repeat
  1074.     Color := RandColor;
  1075.     SetFillStyle(Random(11)+1, Color);
  1076.     SetColor(Color);
  1077.     for I := 1 to MaxPts do
  1078.       with Poly[I] do
  1079.       begin
  1080.         X := Random(MaxX);
  1081.         Y := Random(MaxY);
  1082.       end;
  1083.     FillPoly(MaxPts, Poly);
  1084.   until KeyPressed;
  1085.   WaitToGo;
  1086. end; { PolyPlay }
  1087.  
  1088. procedure FillStylePlay;
  1089. { Display all of the predefined fill styles available }
  1090. var
  1091.   Style    : word;
  1092.   Width    : word;
  1093.   Height   : word;
  1094.   X, Y     : word;
  1095.   I, J     : word;
  1096.   ViewInfo : ViewPortType;
  1097.  
  1098. procedure DrawBox(X, Y : word);
  1099. begin
  1100.   SetFillStyle(Style, White);
  1101.   with ViewInfo do
  1102.     Bar(X, Y, X+Width, Y+Height);
  1103.   Rectangle(X, Y, X+Width, Y+Height);
  1104.   OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Style));
  1105.   Inc(Style);
  1106. end; { DrawBox }
  1107.  
  1108. begin
  1109.   MainWindow('Pre-defined fill styles');
  1110.   GetViewSettings(ViewInfo);
  1111.   with ViewInfo do
  1112.   begin
  1113.     Width := 2 * ((x2+1) div 13);
  1114.     Height := 2 * ((y2-10) div 10);
  1115.   end;
  1116.   X := Width div 2;
  1117.   Y := Height div 2;
  1118.   Style := 0;
  1119.   for J := 1 to 3 do
  1120.   begin
  1121.     for I := 1 to 4 do
  1122.     begin
  1123.       DrawBox(X, Y);
  1124.       Inc(X, (Width div 2) * 3);
  1125.     end;
  1126.     X := Width div 2;
  1127.     Inc(Y, (Height div 2) * 3);
  1128.   end;
  1129.   SetTextJustify(LeftText, TopText);
  1130.   WaitToGo;
  1131. end; { FillStylePlay }
  1132.  
  1133. procedure FillPatternPlay;
  1134. { Display some user defined fill patterns }
  1135. const
  1136.   Patterns : array[0..11] of FillPatternType = (
  1137.   ($AA, $55, $AA, $55, $AA, $55, $AA, $55),
  1138.   ($33, $33, $CC, $CC, $33, $33, $CC, $CC),
  1139.   ($F0, $F0, $F0, $F0, $F, $F, $F, $F),
  1140.   (0, $10, $28, $44, $28, $10, 0, 0),
  1141.   (0, $70, $20, $27, $25, $27, $4, $4),
  1142.   (0, 0, 0, $18, $18, 0, 0, 0),
  1143.   (0, 0, $3C, $3C, $3C, $3C, 0, 0),
  1144.   (0, $7E, $7E, $7E, $7E, $7E, $7E, 0),
  1145.   (0, 0, $22, $8, 0, $22, $1C, 0),
  1146.   ($FF, $7E, $3C, $18, $18, $3C, $7E, $FF),
  1147.   (0, $10, $10, $7C, $10, $10, 0, 0),
  1148.   (0, $42, $24, $18, $18, $24, $42, 0));
  1149. var
  1150.   Style    : word;
  1151.   Width    : word;
  1152.   Height   : word;
  1153.   X, Y     : word;
  1154.   I, J     : word;
  1155.   ViewInfo : ViewPortType;
  1156.  
  1157. procedure DrawBox(X, Y : word);
  1158. begin
  1159.   SetFillPattern(Patterns[Style], White);
  1160.   with ViewInfo do
  1161.     Bar(X, Y, X+Width, Y+Height);
  1162.   Rectangle(X, Y, X+Width, Y+Height);
  1163.   Inc(Style);
  1164. end; { DrawBox }
  1165.  
  1166. begin
  1167.   MainWindow('User defined fill styles');
  1168.   GetViewSettings(ViewInfo);
  1169.   with ViewInfo do
  1170.   begin
  1171.     Width := 2 * ((x2+1) div 13);
  1172.     Height := 2 * ((y2-10) div 10);
  1173.   end;
  1174.   X := Width div 2;
  1175.   Y := Height div 2;
  1176.   Style := 0;
  1177.   for J := 1 to 3 do
  1178.   begin
  1179.     for I := 1 to 4 do
  1180.     begin
  1181.       DrawBox(X, Y);
  1182.       Inc(X, (Width div 2) * 3);
  1183.     end;
  1184.     X := Width div 2;
  1185.     Inc(Y, (Height div 2) * 3);
  1186.   end;
  1187.   SetTextJustify(LeftText, TopText);
  1188.   WaitToGo;
  1189. end; { FillPatternPlay }
  1190.  
  1191. procedure ColorPlay;
  1192. { Display all of the colors available for the current driver and mode }
  1193. var
  1194.   Color    : word;
  1195.   Width    : word;
  1196.   Height   : word;
  1197.   X, Y     : word;
  1198.   I, J     : word;
  1199.   ViewInfo : ViewPortType;
  1200.  
  1201. procedure DrawBox(X, Y : word);
  1202. begin
  1203.   SetFillStyle(SolidFill, Color);
  1204.   SetColor(Color);
  1205.   with ViewInfo do
  1206.     Bar(X, Y, X+Width, Y+Height);
  1207.   Rectangle(X, Y, X+Width, Y+Height);
  1208.   Color := GetColor;
  1209.   if Color = 0 then
  1210.   begin
  1211.     SetColor(White);
  1212.     Rectangle(X, Y, X+Width, Y+Height);
  1213.   end;
  1214.   Color := Succ(Color);
  1215. end; { DrawBox }
  1216.  
  1217. begin
  1218.   MainWindow('256 Color demonstration');
  1219.   Color := 0;
  1220.   GetViewSettings(ViewInfo);
  1221.   with ViewInfo do
  1222.   begin
  1223.     Width := 2 * ((x2-x1+1) div 46);
  1224.     Height := 2 * ((y2-x1+1) div 47);
  1225.   end;
  1226.   X := Width div 3;
  1227.   Y := Height div 3;
  1228.   for J := 1 to 16 do
  1229.   begin
  1230.     for I := 1 to 16 do
  1231.     begin
  1232.       DrawBox(X, Y);
  1233.       Inc(X, (Width div 2) * 3);
  1234.     end;
  1235.     X := Width div 3;
  1236.     Inc(Y, (Height div 2) * 3);
  1237.   end;
  1238.   WaitToGo;
  1239. end; { ColorPlay }
  1240.  
  1241. procedure PalettePlay;
  1242. { Demonstrate the use of the SetRGBPalette command }
  1243. const
  1244.   XBars = 15;
  1245.   YBars = 10;
  1246. type
  1247.   RGBColor   = record
  1248.                  R, G, B : byte;
  1249.                end;
  1250.   VGAPalette = array[0..255] of RGBColor;
  1251.  
  1252. var
  1253.   I, J     : word;
  1254.   X, Y     : word;
  1255.   Color    : word;
  1256.   ViewInfo : ViewPortType;
  1257.   Width    : word;
  1258.   Height   : word;
  1259.   VGAPal   : VGAPalette;
  1260.   Rand     : integer;
  1261.  
  1262. procedure ReadDACBlock(Start, Count : integer; var Pal : VGAPalette);
  1263. var
  1264.   Regs : Registers;
  1265. begin
  1266.   with Regs do
  1267.   begin
  1268.     AH := $10;
  1269.     AL := $17;
  1270.     BX := Start;
  1271.     CX := Count;
  1272.     ES := Seg(Pal);
  1273.     DX := Ofs(Pal);
  1274.   end;
  1275.   Intr($10, Regs);
  1276. end;
  1277.  
  1278. procedure SetDACBlock(Start, Count : integer; var Pal : VGAPalette);
  1279. var
  1280.   Regs : Registers;
  1281. begin
  1282.   with Regs do
  1283.   begin
  1284.     AH := $10;
  1285.     AL := $12;
  1286.     BX := Start;
  1287.     CX := Count;
  1288.     ES := Seg(Pal);
  1289.     DX := Ofs(Pal);
  1290.   end;
  1291.   Intr($10, Regs);
  1292. end;
  1293.  
  1294. begin
  1295.   ReadDACBlock(0, 256, VGAPal);
  1296.   MainWindow('SetRGBPalette demonstration');
  1297.   StatusLine('Press any key...');
  1298.   GetViewSettings(ViewInfo);
  1299.   with ViewInfo do
  1300.   begin
  1301.     Width := (x2-x1) div XBars;
  1302.     Height := (y2-y1) div YBars;
  1303.   end;
  1304.   X := 0; Y := 0;
  1305.   Color := 0;
  1306.   for J := 1 to YBars do
  1307.   begin
  1308.     for I := 1 to XBars do
  1309.     begin
  1310.       SetFillStyle(SolidFill, Color);
  1311.       Bar(X, Y, X+Width, Y+Height);
  1312.       Inc(X, Width+1);
  1313.       Inc(Color);
  1314.       Color := Color mod 16;
  1315.     end;
  1316.     X := 0;
  1317.     Inc(Y, Height+1);
  1318.   end;
  1319.   repeat
  1320.     { SetVGAPalette(Random(16), VGAPal[Random(256)]); }
  1321.     with VGAPal[Random(256)] do
  1322.       SetRGBPalette(Random(16), R, G, B);
  1323.   until KeyPressed;
  1324.   SetDACBlock(0, 256, VGAPal);
  1325.   WaitToGo;
  1326. end; { PalettePlay }
  1327.  
  1328. procedure CrtModePlay;
  1329. { Demonstrate the use of RestoreCrtMode and SetGraphMode }
  1330. var
  1331.   ViewInfo : ViewPortType;
  1332.   Ch       : char;
  1333. begin
  1334.   MainWindow('SetGraphMode / RestoreCrtMode demo');
  1335.   GetViewSettings(ViewInfo);
  1336.   SetTextJustify(CenterText, CenterText);
  1337.   with ViewInfo do
  1338.   begin
  1339.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Now you are in graphics mode');
  1340.     StatusLine('Press any key for text mode...');
  1341.     repeat until KeyPressed;
  1342.     Ch := ReadKey;
  1343.     RestoreCrtmode;
  1344.     Writeln('Now you are in text mode.');
  1345.     Write('Press any key to go back to graphics...');
  1346.     repeat until KeyPressed;
  1347.     Ch := ReadKey;
  1348.     SetGraphMode(GetGraphMode);
  1349.     MainWindow('SetGraphMode / RestoreCrtMode demo');
  1350.     SetTextJustify(CenterText, CenterText);
  1351.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Back in graphics mode...');
  1352.   end;
  1353.   WaitToGo;
  1354. end; { CrtModePlay }
  1355.  
  1356. procedure LineStylePlay;
  1357. { Demonstrate the predefined line styles available }
  1358. var
  1359.   Style    : word;
  1360.   Step     : word;
  1361.   X, Y     : word;
  1362.   ViewInfo : ViewPortType;
  1363.  
  1364. begin
  1365.   ClearDevice;
  1366.   DefaultColors;
  1367.   MainWindow('Pre-defined line styles');
  1368.   GetViewSettings(ViewInfo);
  1369.   with ViewInfo do
  1370.   begin
  1371.     X := 35;
  1372.     Y := 10;
  1373.     Step := (x2-x1) div 11;
  1374.     SetTextJustify(LeftText, TopText);
  1375.     OutTextXY(X, Y, 'NormWidth');
  1376.     SetTextJustify(CenterText, TopText);
  1377.     for Style := 0 to 3 do
  1378.     begin
  1379.       SetLineStyle(Style, 0, NormWidth);
  1380.       Line(X, Y+20, X, Y2-40);
  1381.       OutTextXY(X, Y2-30, Int2Str(Style));
  1382.       Inc(X, Step);
  1383.     end;
  1384.     Inc(X, 2*Step);
  1385.     SetTextJustify(LeftText, TopText);
  1386.     OutTextXY(X, Y, 'ThickWidth');
  1387.     SetTextJustify(CenterText, TopText);
  1388.     for Style := 0 to 3 do
  1389.     begin
  1390.       SetLineStyle(Style, 0, ThickWidth);
  1391.       Line(X, Y+20, X, Y2-40);
  1392.       OutTextXY(X, Y2-30, Int2Str(Style));
  1393.       Inc(X, Step);
  1394.     end;
  1395.   end;
  1396.   SetTextJustify(LeftText, TopText);
  1397.   WaitToGo;
  1398. end; { LineStylePlay }
  1399.  
  1400. procedure UserLineStylePlay;
  1401. { Demonstrate user defined line styles }
  1402. var
  1403.   Style    : word;
  1404.   X, Y, I  : word;
  1405.   ViewInfo : ViewPortType;
  1406. begin
  1407.   MainWindow('User defined line styles');
  1408.   GetViewSettings(ViewInfo);
  1409.   with ViewInfo do
  1410.   begin
  1411.     X := 4;
  1412.     Y := 10;
  1413.     Style := 0;
  1414.     I := 0;
  1415.     while X < X2-4 do
  1416.     begin
  1417.       {$B+}
  1418.       Style := Style or (1 shl (I mod 16));
  1419.       {$B-}
  1420.       SetLineStyle(UserBitLn, Style, NormWidth);
  1421.       Line(X, Y, X, (y2-y1)-Y);
  1422.       Inc(X, 5);
  1423.       Inc(I);
  1424.       if Style = 65535 then
  1425.       begin
  1426.         I := 0;
  1427.         Style := 0;
  1428.       end;
  1429.     end;
  1430.   end;
  1431.   WaitToGo;
  1432. end; { UserLineStylePlay }
  1433.  
  1434.  
  1435. procedure SayGoodbye;
  1436. { Say goodbye and then exit the program }
  1437. var
  1438.   ViewInfo : ViewPortType;
  1439. begin
  1440.   MainWindow('');
  1441.   GetViewSettings(ViewInfo);
  1442.   SetTextStyle(TriplexFont, HorizDir, 4);
  1443.   SetTextJustify(CenterText, CenterText);
  1444.   with ViewInfo do
  1445.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'That''s all folks!');
  1446.   StatusLine('Press any key to quit...');
  1447.   repeat until KeyPressed;
  1448. end; { SayGoodbye }
  1449.  
  1450. begin { program body }
  1451.   ClrScr;
  1452.   writeln('VGA BGI Demo Program  Copyright(c) 1987,1989 Borland International, Inc.');
  1453.   writeln;
  1454.   Initialize;
  1455.   ReportStatus;
  1456.   AspectRatioPlay;
  1457.   FillEllipsePlay;
  1458.   SectorPlay;
  1459.   WriteModePlay;
  1460.   ColorPlay;
  1461.   PalettePlay;
  1462.   PutPixelPlay;
  1463.   PutImagePlay;
  1464.   RandBarPlay;
  1465.   SolidBarPlay;
  1466.   BarPlay;
  1467.   Bar3DPlay;
  1468.   ArcPlay;
  1469.   CirclePlay;
  1470.   PiePlay;
  1471.   LineToPlay;
  1472.   LineRelPlay;
  1473.   LineStylePlay;
  1474.   UserLineStylePlay;
  1475.   TextDump;
  1476.   TextPlay;
  1477.   CrtModePlay;
  1478.   FillStylePlay;
  1479.   FillPatternPlay;
  1480.   PolyPlay;
  1481.   SayGoodbye;
  1482.   CloseGraph;
  1483. end.
  1484.